home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / 8.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  63KB  |  2,172 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #ifndef SEM
  10. #define SEM    1
  11. #endif
  12.  
  13. #include "hdr.h"
  14. #include "vars.h"
  15. #include "attr.h"
  16. #include "dclmapp.h"
  17. #include "errmsgp.h"
  18. #include "sspansp.h"
  19. #include "nodesp.h"
  20. #include "setp.h"
  21. #include "miscp.h"
  22. #include "smiscp.h"
  23. #include "chapp.h"
  24.  
  25. /*
  26.  CHECK HANDLING OF NEW_NAME in newmod    ds 30 jul
  27.  Sort out is_identifier usage        ds 26 nov 84
  28.  Bring C version of find_simple_name in closer correspondence to SETL
  29.  version.    ds 7 aug 84
  30.  
  31.  Note that set imported in collect_imported names is built on every call.
  32.  It is probably dead on return, but I am not copying it when I put in
  33.  in all_imported_names. May be able to do set_free(imported) before
  34.  return from collect_imported_names - look into this later.  ds 2 aug
  35. */
  36.  
  37. /*
  38.  * The following global variable is used for error reporting when
  39.  * several instances of an identifier end up hiding each other and
  40.  * the identifier is seen as undeclared or ambiguous.
  41.  */
  42. static Set all_imported_names; /*TBSL: initialize to (Set)0 */
  43.  
  44.  
  45. static Set collect_imported_names(char *);
  46. static void name_error(Node);
  47. static void find_simple_name(Node);
  48. static void array_or_call(Node);
  49. static int parameterless_callable(Symbol);
  50. static void index_or_slice(Node);
  51. static void find_selected_comp(Node);
  52. static void find_exp_name(Node, Symbol, char *);
  53. static void all_declarations(Node, Symbol, char *, Symbol);
  54. static int has_implicit_operator(Node, Symbol, char *);
  55. static void make_any_id_node(Node);
  56. static int is_appropriate_for_record(Symbol);
  57. static int is_appropriate_for_task(Symbol);
  58. static Symbol renamed(Node, Tuple, Symbol);
  59. static Symbol op_matches_spec(Symbol, Tuple, Symbol);
  60. static void check_modes(Tuple, Symbol);
  61. static void renamed_entry(Node, Tuple);
  62.  
  63. void find_old(Node id_node)                                    /*;find_old*/
  64. {
  65.     /*
  66.      * Establish unique name of identifier, or of syntactic category name.
  67.      * Yield error in the case of undefined identifier.
  68.      * In the case of long and short integers, indicate that they are
  69.      * unimplemented rather than 'undefined'.
  70.      */
  71.     Symbol    u_name;
  72.     char    *id;
  73.     char    *newn;
  74.     int        unsupported;
  75.  
  76.     if (cdebug2 > 3)
  77.         TO_ERRFILE("AT PROC :  find_old");
  78.  
  79.     check_old(id_node);
  80.     if (N_KIND(id_node) != as_simple_name) return; /* added 7 jul */
  81.     u_name = N_OVERLOADED(id_node) ? (Symbol) 0 : N_UNQ(id_node);
  82.     id = N_VAL(id_node);
  83.     if (u_name == symbol_undef) {
  84.         if (streq(id, "LONG_INTEGER") || streq(id, "SHORT_INTEGER")) {
  85.             unsupported = TRUE;
  86.             u_name = symbol_integer; /* new type to use */
  87.         }
  88.         else if (streq(id, "SHORT_FLOAT") || streq(id, "LONG_FLOAT")) {
  89.             unsupported = TRUE;
  90.             u_name = symbol_float; /* new type to use */
  91.         }
  92.         else {
  93.             unsupported = FALSE;
  94.         }
  95.  
  96.         if (!unsupported) {
  97.             /* The identifier is undefined, or not visible. This is an error.*/
  98.             name_error(id_node);
  99.         }
  100.         else {
  101.             /* The identifier names unsupported type. This is error, so
  102.              * issue error message and then change type to avoid further
  103.              * spurious error messages
  104.              */
  105.             errmsg_str("% is not supported in current implementation",
  106.               id, "none", id_node);
  107.             N_UNQ(id_node) = u_name;
  108.             return;
  109.         }
  110.         /* insert in current scope, and give it default type.*/
  111.         if (dcl_get(DECLARED(scope_name), id) == (Symbol)0
  112.           && set_size(all_imported_names) == 0) {
  113.             newn = id;
  114.             u_name = find_new(newn);
  115.             NATURE(u_name)    = na_obj; /* Could be more precise.*/
  116.             N_UNQ(id_node) = u_name;
  117.         }
  118.         TYPE_OF(u_name) = symbol_any;
  119.         ALIAS(u_name) = symbol_any;
  120.     }
  121. }
  122.  
  123. Symbol find_type(Node node) /*;find_type*/
  124. {
  125.     Symbol    type_mark;
  126.  
  127.     /* Resolve a name that must yield a type mark.*/
  128.     find_old(node);
  129.     type_mark = N_UNQ(node);
  130.     if (N_OVERLOADED(node) || type_mark == (Symbol)0
  131.       || !is_type(type_mark) && TYPE_OF(type_mark) != symbol_any) {
  132.         errmsg("Invalid type mark ", "none", node);
  133.         N_UNQ(node) = type_mark = symbol_any;
  134.     }
  135.     return type_mark;
  136. }
  137.  
  138. static void name_error(Node id_node)  /*;name_error*/
  139. {
  140.  
  141.     char    *id;
  142.     char    *names;
  143.  
  144.     if (cdebug2 > 3)
  145.         TO_ERRFILE("AT PROC :  name_error");
  146.     /*
  147.      * Name was not found in environment. This may be because it is undeclared,
  148.      * or because several imported instances of the name hide each other.
  149.      * The marker '?' is also returned when a type name is mentioned in
  150.      * the middle of its own elaboration.
  151.      */
  152.     id = N_VAL(id_node);
  153.     if (set_size(all_imported_names) == 0) {
  154.         if (dcl_get(DECLARED(scope_name), id) == (Symbol)0) {
  155.             errmsg_str("identifier undeclared or not visible %", id, "3.1", id_node);
  156.         }
  157.         else {
  158.             errmsg_str("Invalid reference to %", id , "3.3", id_node);
  159.         }
  160.     }
  161.     else {
  162. #ifdef TBSL
  163.         names = +/[ original_name(scope_of(x)) + '.' + original_name(x)
  164.             + ' ':    x in all_imported_names ];
  165. #endif
  166.         names = build_full_names(all_imported_names);
  167.         errmsg_str("Ambiguous identifier. Could be one of: %",
  168.           names, "8.3, 8.4", id_node);
  169.     }
  170. }
  171.  
  172. void check_old(Node n_node)  /*;check_old*/
  173. {
  174.     Node    node, attr, arg1, expn;
  175.     int    nk;
  176.  
  177.     if (cdebug2 > 3) {
  178.         TO_ERRFILE("AT PROC :  check_old");
  179.         printf("  kind %s\n", kind_str(N_KIND(n_node))); /*DEBUG*/
  180.     }
  181.     /*
  182.      * This procedure performs name resolution for several syntactic
  183.      * instances of names. These include identifiers, selected components,
  184.      * array indexing and slicing, function calls and attribute expressions.
  185.      * If -name- is an identifier and is undeclared, this proc yields
  186.      * the special marker '?' which is used by error routines.
  187.      * If -name- is overloaded, the procedure returns the set of overloaded
  188.      * names which correspond to -name-. This set is constructed by
  189.      * scanning first the open scopes, and then examining visible packages.
  190.      * To facilitate the collection of overloaded names, the procedure
  191.      * chain_overload, which is called when a procedure specification, or
  192.      * and enumeration type are processed, collects successive overloads of the
  193.      * same id together, using the -overloads- field of the symbol table.
  194.      */
  195.  
  196.     switch (nk = N_KIND(n_node)) {
  197.       case    as_simple_name:
  198.       case    as_character_literal:
  199.       case    as_package_stub:
  200.       case    as_task_stub:
  201.                 find_simple_name(n_node);
  202.                 break;
  203.       case    as_call_unresolved:
  204.                 array_or_call(n_node);
  205.                 break;
  206.       case    as_selector:
  207.                 find_selected_comp(n_node);
  208.                 break;
  209.       case    as_string:
  210.                 N_KIND(n_node) = as_simple_name; /* Treat as simple*/
  211.                 find_simple_name(n_node);            /* name.*/
  212.                 break;
  213.       case    as_name:
  214.       case    as_range_expression:
  215.                 node = N_AST1(n_node);
  216.                 find_old(node);
  217.                 copy_attributes(node, n_node);
  218.                 break;
  219.       case    as_attribute:
  220.                 attr = N_AST1(n_node);
  221.                 arg1 = N_AST2(n_node);
  222.                 find_old(arg1);
  223.                 break;
  224.       case    as_all:
  225.                 expn = N_AST1(n_node);
  226.                 find_old(expn);
  227.                 break;
  228.     }
  229. }
  230.  
  231. static void find_simple_name(Node n_node)        /*;find_simple_name*/
  232. {
  233.     char    *id;
  234.     Symbol    sc;
  235.     int        sc_num;
  236.     Symbol    u_name, o, n, u_n;
  237.     Symbol    found, foreign;
  238.     Set        names, names_add, found_set;
  239.     Set imported;
  240.     int        i, exists, found_is_set;
  241.     Forset    fs1, fs2;
  242.     Symbol    sym;
  243.  
  244.     id = N_VAL(n_node);
  245.  
  246.     if (cdebug2 > 0) {
  247.         TO_ERRFILE(" looking for id. " );
  248.         printf("  kind %s %s\n", kind_str(N_KIND(n_node)), id); /*DEBUG*/
  249.     }
  250.  
  251.     exists = FALSE;
  252.     for (sc_num = 1; sc_num <= tup_size(open_scopes); sc_num++) {
  253.         sc = (Symbol)open_scopes[sc_num];
  254.         u_name = dcl_get(DECLARED(sc), id);
  255.         if     (u_name != (Symbol)0) {
  256.             exists = TRUE;
  257.             break;
  258.         }
  259.     }
  260.     if (exists) {
  261.         if (!can_overload(u_name)) {
  262.             found_is_set = FALSE;
  263.             found = u_name;
  264.             TO_XREF(u_name);
  265.         }
  266.         else {
  267.             names = set_copy(OVERLOADS(u_name));
  268.  
  269.             /* Scan open scopes for further overloadings.*/
  270.             for (i = sc_num+1; i <= tup_size(open_scopes); i++) {
  271.                 u_n = dcl_get(DECLARED(((Symbol)open_scopes[i])), id);
  272.                 if (u_n == (Symbol)0) continue;
  273.                 else if (!can_overload(u_n)) {
  274.                     found_is_set = TRUE;
  275.                     found_set = names;
  276.                 }
  277.                 else {
  278.                     names_add = set_new(0);
  279.                     FORSET(o=(Symbol), OVERLOADS(u_n), fs1);
  280.                         exists = FALSE;
  281.                         FORSET(n=(Symbol), names, fs2);
  282.                             if (same_type(TYPE_OF(n), TYPE_OF(o)) &&
  283.                               same_signature(n, o)) {
  284.                                 exists = TRUE;
  285.                                 break;
  286.                             }
  287.